home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / improve.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  9KB  |  250 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun improve (tree &optional dead?)
  4.   (unless (null tree)
  5.     (typecase tree
  6.       (seq (improve-seq tree dead?))
  7.       (unwind-protect (improve-unwind-protect tree dead?))
  8.       (var-ref (improve-var-ref tree dead?))
  9.       (var-def (improve-var-def tree))
  10.       (mvalues (improve-values tree dead?))
  11.       (if (improve-if tree dead?))
  12.       (switch (improve-switch tree dead?))
  13.       (function-call (improve-function-call tree dead?))
  14.       (scope-control-transfer (improve-scope-control-transfer tree))
  15.       (control-point (improve-control-point tree))
  16.       (constant (improve-constant tree dead?))
  17.       (t tree))))
  18.  
  19. (defun improve-constant (tree dead?)
  20.   (if dead? nil tree))
  21.  
  22. (defun improve-list (l &optional dead? body?)
  23.   (loop with end = (last l)
  24.     for rest on l
  25.     do (setf (car rest) (improve (car rest)
  26.                      (if (eq rest end)
  27.                      dead?
  28.                      body?)))
  29.     finally (return l)))
  30.  
  31.  
  32. (defun improve-seq (tree dead?)
  33.   (when (values-seq-p tree)
  34.     (improve-list (values-seq-values tree)))
  35.   (when (scope-seq-p tree)
  36.     (setf (scope-seq-control-point tree)
  37.       (improve (scope-seq-control-point tree))))
  38.   (let ((body (seq-body tree)))
  39.     (setf (seq-body tree)
  40.       (if (listp body)
  41.           (improve-list body dead? t)
  42.           (improve body)))
  43.     tree))
  44.  
  45. (defun improve-values (tree dead?)
  46.   (improve-list (mvalues-args tree) dead?)
  47.   tree)
  48.  
  49. (defun improve-var-ref (tree dead?)
  50.   (if dead? nil tree))
  51.  
  52. (defun improve-var-def (tree)
  53.   (setf (var-def-value tree) (improve (var-def-value tree)))
  54.   tree)
  55.  
  56. (defun improve-function-call (tree dead?)
  57.   (when (unnamed-call-p tree)
  58.     (setf (unnamed-call-function-form tree)
  59.       (improve (unnamed-call-function-form tree))))
  60.   (improve-list (function-call-args tree))
  61.   (let* ((info (function-call-info tree))
  62.      (meta-eval-arg-types (and info
  63.                    (function-info-meta-eval-arg-types info))))
  64.     (if (and (not (null meta-eval-arg-types))
  65.          (every #'(lambda (arg type)
  66.             (and (constant-p arg)
  67.                  (typep (constant-data arg) type)))
  68.             (function-call-args tree)
  69.             meta-eval-arg-types))
  70.     (let ((const (apply
  71.               (function-info-meta-eval-function info)
  72.               (mapcar #'constant-data (function-call-args tree)))))
  73.       (improve (make-constant :tail? (code-tail? tree)
  74.                   :mv-holder (code-mv-holder tree)
  75.                   :out-type (type-macroexpand (type-of const))
  76.                   :line (code-line tree)
  77.                   :data const)
  78.            dead?))
  79.     (let ((method (function-call-rewrite-method tree)))
  80.       (if (null method)
  81.           ;; Shouldn't we move this outside the method lookup?
  82.           (if (and dead? (null (function-call-side-effects? tree)))
  83.           nil
  84.           tree)
  85.           (let* ((info (get-or-create-proc-info
  86.                 (compiler-method-new-function method)))
  87.              (new (etypecase  info
  88.                 (primitive-info
  89.                  (make-primitive-call
  90.                   :tail? (code-tail? tree)
  91.                   :mv-holder (code-mv-holder tree)
  92.                   :out-type (code-out-type tree)
  93.                   :line (code-line tree)
  94.                   :args (function-call-args tree)
  95.                   :info info))
  96.                 (proc-info
  97.                  (make-named-call
  98.                   :name (proc-info-name info)
  99.                   :tail? (code-tail? tree)
  100.                   :mv-holder (code-mv-holder tree)
  101.                   :out-type (code-out-type tree)
  102.                   :line (code-line tree)
  103.                   :args (function-call-args tree)
  104.                   :info info)))))
  105.         (funcall (compiler-method-transform method) new)
  106.         (improve new dead?)))))))
  107.     
  108. (defun function-call-rewrite-method (call)
  109.   (let ((info (function-call-info call)))
  110.     (and (not (null info))
  111.      (typep call '(or named-call foreign-call))
  112.      (loop for method in (function-and-method-info-methods info)
  113.            when (call-matches-method-type-signature? call method)
  114.            do (return method)
  115.            finally (return nil)))))
  116.  
  117. (defun call-matches-method-type-signature? (call method)
  118.   (and (loop for arg in (function-call-args call)
  119.          for method-arg-type in (compiler-method-in-types method)
  120.          unless (and (not (null (code-out-type arg))) ; HEY! zap someday
  121.              (subtypep (code-out-type arg) method-arg-type))
  122.          do (return nil)
  123.          finally (return t))
  124.        ;; HEY! only works for single valued calls
  125.        (subtypep (code-out-type call)
  126.          (first (compiler-method-out-types method)))))
  127.  
  128. (defun improve-if (tree dead?)
  129.   (let ((test (setf (if-test tree) (improve (if-test tree))))
  130.     (then (setf (if-then tree) (improve (if-then tree) dead?)))
  131.     (else (setf (if-else tree) (improve (if-else tree) dead?))))
  132.     (if (and (null then) (null else))
  133.     (improve test dead?)
  134.     (typecase test
  135.       (constant (if (null (constant-data test))
  136.             (if-else tree)
  137.             (if-then tree)))
  138.       ;; (if (if a b c) d e) ==> (if a (if b d e) (if c d e))
  139.       ;; if false C
  140. #|
  141.       (if (let ((new-then (make-if :test (if-then test)
  142.                        :then (if-then tree)
  143.                        :else (if-else tree)))
  144.             (new-else (make-if :test (if-else test)
  145.                        :then (if-then tree)
  146.                        :else (if-else tree))))
  147.         (setf (if-test tree) (if-test test))
  148.         (setf (if-then tree) new-then)
  149.         (setf (if-else tree) new-else)
  150.         (improve-if tree dead?)))
  151. |#
  152.       (t (let ((leaves (tail-leaves test)))
  153.            (when (and (= (length leaves) 1)
  154.               (primitive-call-p (first leaves)))
  155.          (let* ((call (first leaves))
  156.             (info (function-call-info call))
  157.             (args (function-call-args call)))
  158.            (cond ((and (eq (function-info-name info) '%eq)
  159.                    (constant-p (second args))
  160.                    (null (constant-data (second args))))
  161.               ;; Above pattern match depends on the fact
  162.               ;; that NOT and NULL are inlined as (%EQ X NIL)
  163.               (rotatef (if-then tree) (if-else tree))
  164.               (if (eq test call)
  165.                   (setf (if-test tree) (first args))
  166.                   (tree-nsubst (first args) call test))
  167.               (improve-if tree dead?)) ; try for more improvement
  168.              ((eq (car (function-info-out-types info))
  169.                   c-type-if-test)
  170.               (setf (branch-inline-test? tree) t)
  171.               (setf (code-out-type call)
  172.                 c-type-if-test)))))
  173.            tree))))))
  174.  
  175.  
  176. (defun improve-switch (tree dead?)
  177.   (setf (branch-test tree) (improve (branch-test tree)))
  178.   (setf (switch-consequents tree)
  179.     (improve-list (switch-consequents tree) dead?))
  180.   (setf (switch-default tree) (improve (switch-default tree) dead?))
  181.   tree)
  182.  
  183. (defun improve-scope-control-transfer (tree)
  184.   (setf (scope-control-transfer-send-value tree)
  185.     (improve (scope-control-transfer-send-value tree)))
  186.   (setf (scope-control-transfer-destination-point tree)
  187.     (improve (scope-control-transfer-destination-point tree)))
  188.   tree)
  189.  
  190. (defun improve-control-point (tree)
  191.   (typecase tree
  192.     (dynamic-scope-control-point
  193.      (setf (dynamic-scope-control-point-tag-name tree)
  194.        (improve (dynamic-scope-control-point-tag-name tree))))
  195.     (dynamic-tag-control-point
  196.      (setf (dynamic-tag-control-point-tag-name tree)
  197.        (improve (dynamic-tag-control-point-tag-name tree)))))
  198.   tree)
  199.  
  200. (defun improve-unwind-protect (tree dead?)
  201.   (setf (unwind-protect-protected-form tree)
  202.     (improve (unwind-protect-protected-form tree)))
  203.   (setf (unwind-protect-cleanup-form tree)
  204.     (improve (unwind-protect-cleanup-form tree) dead?))
  205.   tree)
  206.  
  207. (defun tail-leaves (tree)
  208.   (unless (null tree)
  209.     (typecase tree
  210.       (seq  (let ((body (seq-body tree)))
  211.           (if (atom body)
  212.           (tail-leaves body)
  213.           (tail-leaves (car (last body))))))
  214.       (scope-control-transfer 
  215.        (tail-leaves (scope-control-transfer-send-value tree)))
  216.       (unwind-protect 
  217.        (tail-leaves (unwind-protect-protected-form tree)))
  218.       (if (append (tail-leaves (if-then tree))
  219.           (tail-leaves (if-else tree))))
  220.       (switch (append (loop for c in (switch-consequents tree)
  221.                 appending (tail-leaves c))
  222.               (tail-leaves (switch-default tree))))
  223.       ((or function-call var-ref constant var-def mvalues) (list tree))
  224.       (t nil))))
  225.  
  226. (defun clear-tree-leaves-tail-slots (tree)
  227.   (unless (null tree)
  228.     (setf (code-tail? tree) nil)
  229.     (typecase tree
  230.       (seq  (let ((body (seq-body tree)))
  231.           (if (atom body)
  232.           (clear-tree-leaves-tail-slots body)
  233.           (clear-tree-leaves-tail-slots (car (last body))))))
  234.       (scope-control-transfer 
  235.        (clear-tree-leaves-tail-slots (scope-control-transfer-send-value tree)))
  236.       (unwind-protect 
  237.        (clear-tree-leaves-tail-slots (unwind-protect-protected-form tree)))
  238.       (if (clear-tree-leaves-tail-slots (if-then tree))
  239.       (clear-tree-leaves-tail-slots (if-else tree)))
  240.       (switch (loop for c in (switch-consequents tree)
  241.             do (clear-tree-leaves-tail-slots c))
  242.     (clear-tree-leaves-tail-slots (switch-default tree)))
  243.       ((or function-call var-ref constant var-def mvalues) (list tree))
  244.       (t nil))))
  245.  
  246. ;;; T or a list of side-effect classes (:CONS, :IO, :STORE)
  247. (defun function-call-side-effects? (tree)
  248.   tree
  249.   t)
  250.